Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-02/tpio24.zip/IO24.PAS

Pascal/Delphi Source File | 1993-01-04 | 43KB | 1,218 lines

{ IO24.PAS -- Global I/O procedures to include in programs generally
  by Bill Meacham
  Ver 2.0 -- includes prev_page and next_page, changes where pause text
             is displayed -- 2/26/86.
             Cosmetic improvements -- 4/16/86.
  Ver 2.l -- Add function Pad -- 10/12/86.
  Ver 2.2 -- Add ability to move cursor within input line -- 5/24/87.
  Ver 2.3 -- Add proc buzz, error_buzz; add buzzes to read routines.
             Converted to Turbo 4.0 -- 12/2/87
             Converted to a Unit -- 12/2/87
             Fix bug in Read_Real -- 1/3/88 -- TP4 cannot handle a trailing
                 decimal point where TP3 could
             Add home_key and end_key -- 1/24/88
             Fix bug in Read_Int -- 2/18/88
             Add Read_Longint and Write_Longint -- 3/19/88
  Ver 2.4 -- Include video routines, etc. from DOS23 -- 3/23/88
             Add procedure Deedle -- 5/1/88
             Add vid_base -- 6/??/88
             Add prior_fld & prior_scrn -- 7/27/88
             Fix minor bug in read_real;
             Remove F1 key; add + 128 to F-keys, etc. -- 8/5/88
             Fixed proc Pause re: Terminating -- 1/8/89
             Changed proc Beep -- 3/15/89 }

{ -------------------------------------------------------------------------- }

unit io24 ;
{$v-}
interface

uses
    crt, dos ;

const
                       { ASCII values of cursor control keys, like WordStar. }
    null      = $00 ;
    prev_char = $13 ;  { ^S }
    next_char = $04 ;  { ^D }
    home_key  = $01 ;  { ^A }
    end_key   = $06 ;  { ^F }
    prev_fld  = $05 ;  { ^E }
    next_fld  = $18 ;  { ^X }
    prev_page = $12 ;  { ^R }
    next_page = $03 ;  { ^C }
    del_char  = $07 ;  { ^G }
    del_left  = $08 ;  { ^H (Backspace) }
    del_fld   = $19 ;  { ^Y }
    del       = $7F ;  { Delete }
    help_key  = $BB ;  { F1 key }
    escape    = $1B ;
    carr_rtn  = $0D ;
    space     = $20 ;
    filler    = $5F ;  { _ }

type
    str1      = string[1] ;
    str14     = string[14] ;
    str_type  = string[80] ;
    byteset   = set of $00 .. $FF ;

const  { Turbo typed constants -- initialized variables }

    terminating : byteset = [carr_rtn,next_fld,prev_fld,escape,next_page,prev_page] ;
    adjusting   : byteset = [prev_char,next_char,home_key,end_key,del_char,del_fld,del_left] ;

(*
 * NOTE -- If you do not want PgDn and PgUp to have an effect in your
 * program, put the following statement in the program that Uses this unit.
 * Put it before calling any of the Read routines (read_str, read_int, etc.).
 *
 *          terminating := terminating - [next_page, prev_page] ;
 *)

var
    fld, scrn,                { For field & screen cursor control }
    prior_fld,                { to save what fld is before it gets changed }
    prior_scrn,               { to save what scrn is before it gets changed }
    bgcolor,                  { background color }
    txcolor     : integer ;   { text color }
    is_mono     : boolean ;   { whether monochrome screen }
    vid_base    : word ;      { video base -- where video ram is }

procedure clrline (col,row : byte) ;
  { clears to end of line }
procedure buzz (pitch,duration : integer) ;
  { makes a sound }
procedure beep ;
  { sounds audible tone }
procedure error_buzz ;
  { makes a particular sound }
procedure deedle(deedles : integer);
  { sounds like a telephone ring; parm deedles is number of rings }
procedure do_fld_ctl (key : integer) ;
  { Adjusts global FLD based on value of key, ORD of last key pressed }
procedure do_scrn_ctl ;
  { Checks value of FLD and adjusts value of SCRN accordingly }
procedure write_str (st:str_type ; col,row:byte) ;
  { writes a string on screen at column and row specified }
procedure write_int (int:integer ; width,col,row:byte) ;
  { writes an integer }
procedure write_longint (lint:longint ; width,col,row:byte) ;
  { writes a long integer }
procedure set_bool (var bool : boolean) ;
  { sets boolean to undefined, neither true nor false }
function defined (bool : boolean) : boolean ;
  { whether boolean is defined }
procedure write_bool (bool:boolean ; col, row:byte) ;
  { writes a boolean as 'YES' or 'NO' }
procedure write_real (r:real ; width,frac,col,row:byte) ;
  { writes a real }
procedure keyin (var ch:char) ;
  { Reads a single character from keyboard without echoing it back.
    Maps function key scan codes to single keyboard keys. }
function build_str (ch : char ; n : integer) : str_type ;
  { returns a string of length n of the character ch }
function pad (st : str_type ; ch : char ; i : integer) : str_type ;
  { Pad string with ch to length of i.
    Do not let i exceed 80 (length of str_type! }
function purgech (instr : str_type ; inchar : char) : str_type ;
  { Purges all instances of the character from the string }
function stripch (instr:str_type ; inchar:char) : str_type ;
  { Strips leading instances of the character from the string }
function chopch (instr:str_type ; inchar:char) : str_type ;
  { Chops trailing instances of the character from the string }
procedure read_str (var st:str_type ; maxlen, col, row:byte) ;
  { Read String.  This procedure gets input from the keyboard one
    character at a time and edits on the fly, rejecting invalid
    characters.  COL and ROW tell where to begin the data input
    field, and MAXLEN is the maximum length of the string to be
    returned. }
procedure read_int (var int:integer ; maxlen, col, row:byte) ;
  { Read Integer.  This procedure gets input from the keyboard
    one character at a time and edits on the fly, rejecting
    invalid characters.  COL and ROW tell where to begin the data
    input field, and MAXLEN is the maximum length of the integer
    to be returned. }
procedure read_longint (var lint:longint ; maxlen, col, row:byte) ;
  { Read Long Integer.  Just like read_int. }
function equal (r1,r2 : real) : boolean ;
  { Tests functional equality of two real numbers.
    True if r1 = r2. }
function greater (r1,r2 : real) : boolean ;
  { Tests functional inequality of two real numbers.
    True if r1 > r2. }
procedure read_real (var r:real ; maxlen,frac,col,row:byte) ;
  { Read Real.  This procedure gets input from the keyboard
    one character at a time and edits on the fly, rejecting
    invalid characters.  COL and ROW tell where to begin the data
    input field; MAXLEN is the maximum length of the string
    representation of the real number, including sign and decimal
    point; FRAC is the fractional part, the number of digits to
    right of the decimal point. }
procedure read_yn (var bool:boolean; col,row:byte) ;
  { Inputs "Y" OR "N" to boolean at column and row specified,
    prints "YES" or "NO."
    Note -- use this when the screen control will not return
    to the question and the boolean IS NOT defined before the
    user answers the question.  Does not affect global FLD. }
procedure read_bool (var bool:boolean; col,row:byte) ;
  { Displays boolean at column and row specified, inputs "Y"
    or "N" to set new value of boolean, prints "YES" or "NO."
    Boolean is "forced;" user cannot cursor forward past undefined
    boolean.  Pressing "Y" or "N" terminates entry. }
procedure pause ;
  { Prints message on bottom line, waits for user response. }
procedure hard_pause ;
  { Like Pause, but only accepts space bar or Escape and only goes forward }

procedure rvson ;
  { turn reverse video on }
procedure rvsoff ;
  { turn reverse video off }
procedure emphon ;
  { turn emphasis on -- if text is dim, make it bright; if bright make it dim }
procedure emphoff ;
  { turn emphasis off }
procedure assigncolors ;
  { change colors on display -- border same as background, but only on CGA }
procedure getdrive (var drive : str1) ;
  { get current drive }

procedure show_msg (msg : str_type) ;
  { Beeps, displays message centered on line 23, pauses }

{ ========================================================================== }

implementation

var
    regs : registers ;

{ procedure gotoxy (col,row) ; -- Built-in proc in Turbo to place
  cursor on screen.  Upper left is (1,1) not (0,0)! }

{ procedure clrscr ; -- Built-in proc in Turbo to clear screen. }

{ procedure clreol ; -- built-in proc in Turbo to clear to end of line }

{ -------------------------------------------------------------------------- }

procedure clrline (col,row : byte) ;
    begin
        gotoxy (col,row) ;
        clreol
    end ;

{ -------------------------------------------------------------------------- }

procedure buzz (pitch,duration : integer) ;
  begin
    sound(pitch) ;
    delay(duration) ;
    nosound
  end ;

{ -------------------------------------------------------------------------- }

procedure beep ;
  begin
    buzz(456,200) ;
  end ;

{ -------------------------------------------------------------------------- }

procedure error_buzz ;
  begin
    buzz (50,100)
  end ;

{ -------------------------------------------------------------------------- }

{->>>>Deedle<<<<-----------------------------------------------}
{                                                              }
{ Filename: DEEDLE.SRC -- Last Modified 10/20/85               }
{                                                              }
{ This routine makes a sound not unlike certain electronic     }
{ telephone ringers you hear in lawyers' offices.  The number  }
{ of "deedles" is given by the value passed in Deedles.        }
{                                                              }
{        From: TURBO PASCAL SOLUTIONS by Jeff Duntemann        }
{    Scott, Foresman & Co., Inc. 1987   ISBN 0-673-18584-2     }
{--------------------------------------------------------------}

PROCEDURE Deedle(Deedles : Integer);

VAR I : Integer;

BEGIN
  FOR I := 1 TO Deedles DO
    BEGIN
      Sound(800); Delay(50); Sound(500); Delay(50)
    END;
  NoSound
END;

{ -------------------------------------------------------------------------- }

procedure do_fld_ctl (key : integer) ;
  { Adjusts global FLD based on value of key, the ordinal value of last key pressed }
  { global
        fld       : integer -- for field cursor control
        prior_fld : integer -- to save what fld is before it gets changed }
    begin
        prior_fld := fld ;
        case key of
          carr_rtn, next_fld : fld := succ(fld) ;
          prev_fld           : fld := pred(fld) ;
          next_page          : fld := 999 ;
          prev_page          : fld := -999 ;
          escape             : fld := maxint ;
        end  { case }
    end ;  { proc do_fld_ctl }

{ ------------------------------------------------------------ }

procedure do_scrn_ctl ;
  { Checks value of FLD and adjusts value of SCRN accordingly }
  { Global
        fld, scrn  : integer -- For field and screen cursor control
        prior_scrn : integer -- to save what scrn is before it gets changed }
    begin
        prior_scrn := scrn ;
        if fld < 1 then
            scrn := pred(scrn)
        else if fld = maxint then
            scrn := maxint
        else
            scrn := succ(scrn)
    end ;

{ ------------------------------------------------------------ }

procedure write_str (st:str_type ; col,row:byte) ;
    begin
        gotoxy (col,row) ;
        write (st)
    end ;

{ -------------------------------------------------------------------------- }

procedure write_int (int:integer ; width,col,row:byte) ;
    begin
        gotoxy (col,row) ;
        write (int:width)
    end ;

{ -------------------------------------------------------------------------- }

procedure write_longint (lint:longint ; width,col,row:byte) ;
    begin
        gotoxy (col,row) ;
        write (lint:width)
    end ;

{ -------------------------------------------------------------------------- }

procedure set_bool (var bool : boolean) ;
  { Sets boolean to be undefined, neither true nor false.
    Boolean is stored as one byte:
        $80 = undefined
        $01 = true
        $00 = false.
    Note : Turbo interprets $80 as true because it is greater than zero! }

    var
        b : byte absolute bool ;
    begin
        b := $80
    end ;  { proc set_bool }

{ -------------------------------------------------------------------------- }

function defined (bool : boolean) : boolean ;
  { Determines whether the boolean is defined or not }
    var
        b : byte absolute bool ;
    begin
        defined := not (b = $80)
    end ;  { function defined }

{ -------------------------------------------------------------------------- }

procedure write_bool (bool:boolean ; col, row:byte) ;
    begin
        gotoxy (col,row) ;
        if not defined(bool) then
            write ('___')
        else if bool then
            write ('YES')
        else
            write ('NO ')
    end ;

{ -------------------------------------------------------------------------- }

procedure write_real (r:real ; width,frac,col,row:byte) ;
    begin
        gotoxy (col,row) ;
        write (r:width:frac)
    end ;

{ -------------------------------------------------------------------------- }

procedure keyin (var ch:char) ;
{ Reads a single character from keyboard without echoing it back.
  Maps function key scan codes to single keyboard keys.
  From Turbo 3.0 manual, page 360 -- 5/29/85
  Modified for IO20 -- 2/26/86
  Modified for IO23 -- 5/24/87
  Modified for Turbo 4.0 -- 11/26/87
  Delete F1 key; add 128 to F-keys, etc. -- 8/5/88 }

    var
           c : char ;        { Character read }
         key : integer ;     { ORD of character returned }

    begin
        c := readkey ;                    { Get first char }
        if  (ord(c) = null) then          { If there is a second ... }
          begin
            c := readkey ;                { Get 2nd char }
            if ord(c) < 128 then
                c := chr(ord(c) + 128) ;  { Translate F keys to single value }
          end ;
        key := ord(c) ;

        case key of
                                        { Translate F-keys and arrow keys }
          191,203 : key := prev_char ;  { F5, left-arrow }
          192,205 : key := next_char ;  { F6, right-arrow }
          199     : key := home_key ;   { Home }
          207     : key := end_key ;    { End }
          189,200 : key := prev_fld ;   { F3, up-arrow }
          190,208 : key := next_fld ;   { F4, down-arrow }
          193,201 : key := prev_page ;  { F7, PgUp }
          194,209 : key := next_page ;  { F8, PgDn }
          211     : key := del_char ;   { DEL }
          188     : key := del_fld ;    { F2 }
                                        { CP/M-like control keys }
          $0B     : key := prev_fld ;   { ^K }
          $0A     : key := next_fld ;   { ^J }
          $0C     : key := next_char ;  { ^L }
        end ;  { case }

        ch := chr(key)                    { finally, return the character }
    end ; { procedure keyin }

{ ------------------------------------------------------------ }

function build_str (ch : char ; n : integer) : str_type ;
  { returns a string of length n of the character ch }
    var
        st : str_type ;
    begin
        if n < 0 then
            n := 0 ;
        st[0] := chr(n) ;
        fillchar (st[1],n,ch) ;
        build_str := st
    end ;  { function build_str) ;

{ -------------------------------------------------------------------------- }

function pad (st : str_type ; ch : char ; i : integer) : str_type ;
{ Pad string with ch to length of i.  Do not let i exceed 80 (length of str_type! }
  var
    l : integer ;
  begin
    l := length(st) ;
    if l < i then
      begin
        fillchar (st[l+1],i-l,ch) ;
        st[0] := chr(i)
      end ;
    pad := st
  end;

{ ------------------------------------------------------------ }

procedure adjust_str (var st : str_type ;
                      var  p : byte ;     { position of char to left of cursor }
                         key,             { ord of adjusting character }
            maxlen, col, row : byte ) ;
  { Adjusts position of cursor within string, deletes characters, etc. }
    begin
      case key of
        home_key  : p := 0 ;
        end_key   : p := length(st) ;
        prev_char : if p > 0 then
                        p := pred(p)
                    else
                        error_buzz ;
        next_char : if p < length(st) then
                        p := succ(p)
                    else
                        error_buzz ;
        del_left  : if p > 0 then
                      begin
                        delete (st,p,1) ;
                        write (^H,copy(st,p,maxlen),chr(filler)) ;
                        p := pred(p)
                      end
                    else
                        error_buzz ;
        del_char  : if p < length(st) then
                      begin
                        delete (st,p+1,1) ;
                        write (copy(st,p+1,maxlen),chr(filler))
                      end
                    else
                        error_buzz ;
        del_fld   : begin
                      st := '' ;
                      p := 0  ;
                      write_str (build_str(chr(filler),maxlen),col,row)
                    end
      end  { case }
    end ; { proc adjust_str }

{ -------------------------------------------------------------------------- }

function purgech (instr : str_type ; inchar : char) : str_type ;
    {Purges all instances of the character from the string}
    var
        n      : integer ;  {Loop counter}
        outstr : str_type ; {Result string}

    begin
        outstr := '' ;
        for n := 1 to length (instr) do
                if not (instr[n] = inchar) then
                        outstr := concat (outstr, instr[n]) ;
        purgech := outstr
    end ;

{ -------------------------------------------------------------------------- }

function stripch (instr:str_type ; inchar:char) : str_type ;
    {Strips leading instances of the character from the string}
    begin
        while not (length(instr) = 0)
        and (instr[1] = inchar) do
                delete (instr, 1, 1) ;
        stripch := instr
    end ;

{ -------------------------------------------------------------------------- }

function chopch (instr:str_type ; inchar:char) : str_type ;
    {Chops trailing instances of the character from the string}
    begin
        while not (length(instr) = 0)
        and (instr[length(instr)] = inchar) do
                delete (instr, length(instr), 1) ;
        chopch := instr
    end ;

{ -------------------------------------------------------------------------- }

procedure read_str (var st:str_type ; maxlen, col, row:byte) ;

  { Read String.  This procedure gets input from the keyboard one
    character at a time and edits on the fly, rejecting invalid
    characters.  COL and ROW tell where to begin the data input
    field, and MAXLEN is the maximum length of the string to be
    returned.

    Revised 6/04/85 -- WPM }

    var
        ch   : char ;     { character from keyboard }
        key  : integer ;  { ord(ch) }
        p    : byte ;     { position of char to left of cursor }

    procedure add_to_str ;
        begin
          if not (length(st) = maxlen) then
            begin
              p := p + 1 ;
              insert (ch,st,p) ;
              write (copy(st,p,maxlen))
            end
          else
              error_buzz
        end ; {--- of add_to_str ---}

    begin {--- read_str ---}
        write_str (st, col, row) ;
        write (build_str(chr(filler),maxlen - length(st))) ;
        p := length(st) ;
        repeat
            gotoxy (col + p, row) ;
            keyin (ch) ;
            key := ord(ch) ;
            if key in [$20 .. $7E] then  { printable character }
                add_to_str
            else if key in adjusting then
                adjust_str (st,p,key,maxlen,col,row)
            else if key in terminating then
                do_fld_ctl (key)
            else
                error_buzz
        until key in terminating ;
        gotoxy (col + length(st), row) ;
        write ('':maxlen - length(st))
    end ; {--- of read_str ---}

{ -------------------------------------------------------------------------- }

procedure read_int (var int:integer ; maxlen, col, row:byte) ;

  { Read Integer.  This procedure gets input from the keyboard
    one character at a time and edits on the fly, rejecting
    invalid characters.  COL and ROW tell where to begin the data
    input field, and MAXLEN is the maximum length of the integer
    to be returned.

    Revised 6/04/85 -- WPM }

    const
        maxst : string[5] = '32767' ;  { string representation of maxint }

    var
        ch    : char ;       { character from keyboard }
        key   : integer ;    { ord(ch) }
        p     : byte ;       { position of char to left of cursor }
        st    : string[5] ;  { string representation of integer }
        code  : integer ;    { result of string to integer conversion }

    procedure add_to_str ;
        begin
          if not (length(st) = maxlen) then
            begin
              p := p + 1 ;
              insert (ch,st,p) ;
              write (copy(st,p,maxlen))
            end
          else
              error_buzz
        end ; {--- of add_to_str---}

    begin {--- read_int ---}
        str (int:maxlen, st) ;          { convert integer into string }
        st := purgech (st, ' ') ;
        st := stripch (st, '0') ;
        write_str (st, col, row) ;
        write (build_str(chr(filler),maxlen - length(st))) ;
        p := length(st) ;
        repeat
            gotoxy (col + p, row) ;
            keyin (ch) ;
            key := ord(ch) ;
            if key = $2D then                 { minus sign }
              begin
                if  (pos('-',st) = 0)
                and (length(st) < maxlen)
                and (p = 0) then
                    add_to_str
                else
                    error_buzz
              end
            else if key in [$30 .. $39] then  {digits 0 - 9}
              begin
                add_to_str ;
                if (length(st) = 5)
                and (st > maxst) then
                  begin
                    delete (st,p,1) ;
                    write (^H,copy(st,p,maxlen),chr(filler)) ;
                    p := p - 1 ;
                    error_buzz
                  end
              end
            else if key in adjusting then
                adjust_str (st,p,key,maxlen,col,row)
            else if key in terminating then
                do_fld_ctl (key)
            else
                error_buzz
        until key in terminating ;
        if (st = '')
        or (st = '-') then
          begin
            int := 0 ;
            code := 0
          end
        else
            val (st, int, code) ;              {Make string into integer}

        if code = 0 then                       {Conversion worked OK}
          begin
            gotoxy (col, row) ;
            write (int:maxlen)
          end
        else
          begin
            gotoxy (col+maxlen,row) ;
            write ('** CONVERSION ERROR ', code) ;
            halt
          end
end ; {--- of read_int ---}

{ -------------------------------------------------------------------------- }

procedure read_longint (var lint:longint ; maxlen, col, row:byte) ;

  { Read Long Integer.  Just like read_int.

    Revised 3/19/88 -- WPM }

    const
        maxst : string[10] = '2147483647' ;  { string representation
                                               of maximum longint }

    var
        ch    : char ;       { character from keyboard }
        key   : integer ;    { ord(ch) }
        p     : byte ;       { position of char to left of cursor }
        st    : string[10] ; { string representation of longint }
        code  : integer ;    { result of string to integer conversion }

    procedure add_to_str ;
        begin
          if not (length(st) = maxlen) then
            begin
              p := p + 1 ;
              insert (ch,st,p) ;
              write (copy(st,p,maxlen))
            end
          else
              error_buzz
        end ; {--- of add_to_str---}

    begin {--- read_longint ---}
        str (lint:maxlen, st) ;          { convert integer into string }
        st := purgech (st, ' ') ;
        st := stripch (st, '0') ;
        write_str (st, col, row) ;
        write (build_str(chr(filler),maxlen - length(st))) ;
        p := length(st) ;
        repeat
            gotoxy (col + p, row) ;
            keyin (ch) ;
            key := ord(ch) ;
            if key = $2D then                 { minus sign }
              begin
                if  (pos('-',st) = 0)
                and (length(st) < maxlen)
                and (p = 0) then
                    add_to_str
                else
                    error_buzz
              end
            else if key in [$30 .. $39] then  {digits 0 - 9}
              begin
                add_to_str ;
                if (length(st) = 10)
                and (st > maxst) then
                  begin
                    delete (st,p,1) ;
                    write (^H,copy(st,p,maxlen),chr(filler)) ;
                    p := p - 1 ;
                    error_buzz
                  end
              end
            else if key in adjusting then
                adjust_str (st,p,key,maxlen,col,row)
            else if key in terminating then
                do_fld_ctl (key)
            else
                error_buzz
        until key in terminating ;
        if (st = '')
        or (st = '-') then
          begin
            lint := 0 ;
            code := 0
          end
        else
            val (st, lint, code) ;             {Make string into integer}

        if code = 0 then                       {Conversion worked OK}
          begin
            gotoxy (col, row) ;
            write (lint:maxlen)
          end
        else
          begin
            gotoxy (col+maxlen,row) ;
            write ('** CONVERSION ERROR ', code) ;
            halt
          end
end ; {--- of read_longint ---}

{ -------------------------------------------------------------------------- }

function equal (r1,r2 : real) : boolean ;
  { tests functional equality of two real numbers -- 4/30/85 }
    begin
        equal := abs(r1 - r2) < 1.0e-5
    end ;  { function equal }

{ -------------------------------------------------------------------------- }

function greater (r1,r2 : real) : boolean ;
  { tests functional inequality of two real numbers -- 5/1/85 }
    begin
        greater := (r1 - r2) > 1.0e-5
    end ;  { function greater }

{ -------------------------------------------------------------------------- }

procedure read_real (var r:real ; maxlen,frac,col,row:byte) ;

  { Read Real.  This procedure gets input from the keyboard one character at
    a time and edits on the fly, rejecting invalid characters.  COL and ROW
    tell where to begin the data input field; MAXLEN is the maximum length of
    the string representation of the real number, including sign and decimal
    point; FRAC is the fractional part, the number of digits to right of the
    decimal point.

    Note -- In Turbo the maximum number of significant digits in decimal (not
    scientific) representation is 11.  In TurboBCD, the maximum number of
    significant digits is 18.  It is the programmer's responsibility to limit
    input and computed output to the maximum significant digits.

    Define MAXLEN as at least two more than FRAC.  When a real less than one
    is written, Turbo puts a leading zero on it.  If it is negative, Turbo
    puts a leading minus sign and zero.  This can corrupt your display unless
    you allow space for the extra characters.

    8/5/88 -- Fixed bug when user deletes the decimal point and the number is
    too big and it disappears.  Now the next digit is read correctly. }

    var
        ch   : char ;       { Input character }
        key  : integer ;    { ord(ch) }
        p    : byte ;       { position of char to left of cursor }
        st   : string[21] ; { String representation of real number -- }
                            { max digits + minus sign + dec point + one extra }
        code : integer ;    { Result of VAL conversion }
        rlen,               { Current length of st to right of dec. pt. }
        llen,               { Current length to left, including dec. pt. }
        maxl,               { Max allowable to left, including dec. pt. }
        posdec : byte ;     { position of decimal point in string }

  { +++++++++++++++++++++++++++++++++++++ }

    procedure compute_length ;
      { Compute length of left and right portions of string }
        begin
            posdec := pos('.',st) ;
            if posdec = 0 then                { If no dec. pt. ... }
                begin
                    llen := length(st) ;      { the whole string is Left }
                    rlen := 0                 { and none is Right }
                end
            else    {There is a decimal point ...}
                begin
                    llen := posdec ;          { Left is all up to and incl. dec. pt. }
                    rlen := length(st) - llen { Right is the rest }
                end
        end ; { proc compute_length }

  { +++++++++++++++++++++++++++++++++++++ }

    procedure add_to_str ;

        procedure add_it ;
            begin
              p := p + 1 ;
              insert (ch,st,p) ;
              write (copy(st,p,maxlen))
            end ;

        begin {add_to_str}
            posdec := pos ('.',st) ;
            if ch = '.' then        { Decimal point; if room, add it }
              begin
                if  (posdec = 0)
                and (length(st) - p <= frac) then
                    add_it
              end
                                    { else it's not a decimal point }
                                    { see if digit fits in whole part }
            else if  (    (posdec = 0)
                      and (llen < maxl - 1)  { only dec. pt. allowed in pos. maxl }
                     )
                 or  (    (posdec > 0)
                      and (llen < maxl)
                      and (p < posdec)
                     ) then

                add_it

                                    { digit is candidate for fractional part }
            else if  (not(posdec = 0))
                 and (p >= posdec)
                 and (rlen < frac) then

                add_it
            else
                error_buzz

        end ; {--- of add_to_str---}

  { +++++++++++++++++++++++++++++++++++++ }

    begin {--- read_real ---}
                              {Initialize}
        maxl  := maxlen - frac ;

                              {Set up string representation of real and }
                              {determine length of left & right portions}

        str(r:maxlen:frac,st) ;           {Make real into string}
        st := purgech (st, ' ') ;         {Purge all blanks}
        st := stripch (st, '0') ;         {Strip leading zeroes}
        if not (pos('.', st) = 0) then    {If there is a dec. pt ... }
            begin
                st := chopch (st, '0') ;  {Chop trailing zeroes}
                st := chopch (st, '.')    {and trailing dec. pt.}
            end ;
        compute_length ;

                              {Write string on console}

        write_str (st, col, row) ;
        write (build_str(chr(filler),maxlen - length(st))) ;
        p := length(st) ;

                              {Get input a character at a time & edit it}

        repeat
            gotoxy (col + p, row) ;
            compute_length ;
            if (    (posdec = 0)
                and (llen > maxl - 1)
               )
            or (    (not (posdec = 0))
                and (llen > maxl)
               )
            or (rlen > frac) then                  { if number is larger than }
              begin                                { spec then delete it all }
                key := del_fld ;
                adjust_str (st,p,key,maxlen,col,row) ;
                compute_length ;
                gotoxy (col,row) ;
                beep
              end ;
            keyin (ch) ;
            key := ord(ch) ;
            if key = $2D  then                      { minus sign }
              begin
                if  (pos('-',st) = 0)
                and (p = 0)
                and (  (    (posdec = 0)
                        and (llen < maxl - 1)
                       )
                    or (    (not (posdec = 0))
                        and (llen < maxl)
                       )
                    ) then

                    add_to_str
                else
                    error_buzz
              end
            else if key in [$2E, $30 .. $39] then   { decimal point, numeric digits }
                add_to_str
            else if key in adjusting then
                adjust_str (st,p,key,maxlen,col,row)
            else if key in terminating then
                do_fld_ctl (key)
            else
                error_buzz
        until key in terminating ;

                              {Done getting input, now convert back to real}
        code := -1 ;                             {Use Code as a flag}
        if (st = '')                             {If null string ... }
        or (st = '.')
        or (st = '-')
        or (st = '-.') then
          begin
            r := 0.0 ;                           {Make real zero}
            code := 0
          end
        else if (pos ('.',st) = 1) then          {If not null string, we must }
            insert ('0',st,1)                    {check for a decimal point   }
        else if (pos ('.',st) = 2)               {before any digits, which is }
        and     (pos ('-',st) = 1) then          {OK in Turbo 3.0 but not 4.0.}
            insert ('0',st,2)                    {If we find one, we insert a }
                                                 {0 so conversion will work.  }

        else if (pos('.', st) = length(st)) then {If there is a trailing dec. }
            delete (st,length(st),1) ;           {point we must get rid of it.}
                                                 {Yet another incompatibility }
                                                 {with Turbo 3.0!             }

        if code = -1 then                        {Real is not zero, so }
            val (st,r,code) ;                    {convert string into real}

        if code = 0 then                         {Conversion worked OK}
          begin
            gotoxy (col, row) ;
            write (r:maxlen:frac)                {Write the real on screen}
          end
        else
          begin
            gotoxy (col+maxlen,row) ;
            write ('** CONVERSION ERROR ', code) ;
            halt
          end
end ; {--- of read_real ---}

{ -------------------------------------------------------------------------- }

procedure read_yn (var bool:boolean; col,row:byte) ;
  { Inputs "Y" OR "N" to boolean at column and row specified,
    prints "YES" or "NO."

    Note -- use this when the screen control will not return
    to the question and the boolean IS NOT defined before the
    user answers the question.  Does not affect global FLD. }

    var ch:char ;
    begin
        gotoxy (col,row) ;
        write ('   ') ;
        gotoxy (col,row) ;
        repeat
            keyin (ch) ;
            ch := upcase(ch) ;
            if not (ch in ['Y','N']) then error_buzz
        until (ch in ['Y','N']) ;
        if (ch = 'Y') then
            begin
                write ('YES') ;
                bool := true
            end
        else
            begin
                write ('NO ') ;
                bool := false
            end
    end ; { proc read_yn }

{ ------------------------------------------------------------ }

procedure read_bool (var bool:boolean; col,row:byte) ;
  { Displays boolean at column and row specified, inputs "Y"
    or "N" to set new value of boolean, prints "YES" or "NO."
    Boolean is "forced;" user cannot cursor forward past undefined
    boolean.  Pressing "Y" or "N" terminates entry.

    Boolean is stored as one byte:
        $80 = undefined
        $01 = true
        $00 = false.
    Note : Turbo interprets $80 as true because it is greater than zero! }

    var
        ch  : char ;
        key : integer ;

    begin
        write_bool (bool, col, row) ;
        gotoxy (col, row) ;
        repeat
            keyin (ch) ;
            key := ord(ch) ;
            if key in [$59,$79] then          { 'Y','y' }
              begin
                bool := true ;
                key  := next_fld ;
                do_fld_ctl(key)
              end
            else if key in [$4E, $6E] then    { 'N','n' }
              begin
                bool := false ;
                key  := next_fld ;
                do_fld_ctl(key)
              end
            else if key in terminating then
              begin
                if  (not defined(bool))
                and (key in [carr_rtn, next_fld, next_page]) then
                  begin
                    key := $00 ;
                    error_buzz
                  end
                else
                    do_fld_ctl (key)
              end
            else
                error_buzz
        until key in terminating ;
        write_bool (bool, col, row)
    end ; {--- of read_bool ---}

{ -------------------------------------------------------------------------- }

procedure pause ;
    {Prints message on bottom line, waits for user response}
    var
        ch        : char ;
        key       : integer ;
        save_term : byteset ;
    begin
        clrline (1,24) ;
        write_str ('PRESS SPACE BAR TO CONTINUE OR UP-ARROW TO GO BACK',14,24) ;
        save_term := terminating ;
        terminating := terminating - [carr_rtn, next_page] ;
        repeat
            keyin (ch) ;
            key := ord(ch) ;
            if key = next_fld then
                key := $00
            else if key = $20 then
                key := next_fld ;
            if key in terminating then
                do_fld_ctl (key)
            else
                error_buzz
        until key in terminating ;
        terminating := save_term ;
        clrline (1,24)
    end ; { proc pause }

{ ------------------------------------------------------------ }

procedure hard_pause ;
  { Like Pause, but only accepts space bar or Escape and only goes forward }
    var
        ch   : char ;
        key : integer ;
    begin
        clrline (1,24) ;
        write_str ('PRESS SPACE BAR TO CONTINUE',26,24) ;
        prior_fld := fld ;
        repeat
            keyin (ch) ;
            key := ord(ch) ;
            case key of
              $20      : fld := succ(fld) ;
              escape   : fld := maxint ;
              else
                  error_buzz
            end ;
        until key in [$20, escape] ;
        clrline (1,24)
    end ; { proc hard_pause }

{ ------------------------------------------------------------ }

procedure rvson ;
{ turn reverse video on }
  begin
    textcolor(bgcolor) ;
    textbackground(txcolor)
  end ;

procedure rvsoff ;
{ turn reverse video off }
  begin
    textcolor(txcolor) ;
    textbackground(bgcolor)
  end ;

procedure emphon ;
{ turn emphasis on -- if text is dim, make it bright; if bright make it dim }
  begin
    if txcolor in [0..7] then
      textcolor(txcolor + 8)
    else
      textcolor(txcolor - 8)
  end ;

procedure emphoff ;
{ turn emphasis off }
  begin
      textcolor(txcolor)
  end ;

{ ------------------------------------------------------------- }

procedure assigncolors ;
  { change colors on display -- border same as background, but only on CGA }
  var
    regs : registers ;

  begin
    textbackground(bgcolor) ;       { set background color }
    regs.AX := $0B00  ;             { set border on CGA }
    regs.BX := bgcolor and $00FF ;
    intr($10,regs) ;
    textcolor(txcolor)              { set text color }
  end ;  { proc assigncolors }

{ ------------------------------------------------------------- }

procedure getdrive (var drive : str1) ;
  { get current drive }

    var regs : registers ;

    begin
      with regs do
        begin
          AX := $1900 ;
          msdos(Dos.Registers(regs)) ;
          drive := chr(AL + $41)
        end
    end ; { proc getdrive }

{ ------------------------------------------------------------- }

procedure show_msg (msg : str_type) ;
  { Beeps, displays message centered on line 23, pauses }

    var
        savefld : integer ;

    begin
        savefld := fld ;
        beep ;
        clrline (1,23) ;
        write_str (msg,((80-length(msg)) div 2),23) ;
        hard_pause ;
        clrline (1,23) ;
        fld := savefld ;
    end ; { proc show_msg }

{ ---- Initialization code ---------------------------------------------- }

begin                              { set up global environment }
    regs.AX := $0F00 ;
    intr ($10,regs) ;
    is_mono := (regs.AL = 7) ;     { get video mode }
    if is_mono then
      begin
        bgcolor  := 0 ;
        txcolor  := 7 ;
        vid_base := $B000
      end
    else
      begin
        bgcolor  := 1 ;
        txcolor  := 7 ;
        vid_base := $B800
      end ;
    assigncolors ;                 { turn on screen colors }
    checkbreak := false            { do not allow Ctrl-Break to halt pgm }
end. { implementation }

{ ----- EOF IO24.PAS ---------------------------------------------------- }